open Glob.Bin

(** Wrappers over Gtk, intended to make more concise and simple
 usual gui programming. I use functions with polymorphic variants as
 arguments (instead objects and methods). *)

let tooltips = GData.tooltips ()

type common_properties = 
    [ `Help of string
    ]
let process_common c = function
    | `Help s ->
            tooltips#set_tip c ~text:s
(*    | _ -> ()*)
;;
type misc_properties = 
    [ `Size of int * int
    ]
let process_misc (obj: < misc: GObj.misc_ops; ..>) = 
    function
    | `Size (width,height) -> 
            obj#misc#set_size_request ~width ~height ()
;;
type common_misc_properties = [ common_properties | misc_properties ]
let process_common_misc
        (obj: < misc: GObj.misc_ops; coerce: GObj.widget; ..>) =
  function
  | #common_properties as p -> process_common obj#coerce p
  | #misc_properties as p -> process_misc obj p
;;
let select_common_misc properties = 
    List.fold_left (fun acc elt -> 
        match elt with
        | #common_misc_properties as p -> p::acc
        | _ -> acc
    ) [] properties

(** [main widgets] *)

let window title properties content =
    let w = GWindow.window ~title () in
    let c = w#coerce in
    let declare = ( function
        | `Main ->
                ignore (w#connect#destroy ~callback:GMain.Main.quit);
        | `Border_width i ->
                w#set_border_width i
    ) in
    List.iter declare properties;
    w#add content;
    w#show ();
    c

let button text properties =
    let b = GButton.button ~label:text () in
    let c = b#coerce in
    let declare = ( function
        | `Pressed f -> 
                ignore (b#connect#clicked ~callback:f)
        | `Help s ->
                tooltips#set_tip c ~text:s
    ) in
    List.iter declare properties;
    c
;;

let check_button text properties =
    let active = List.mem `Active properties in
    let b = GButton.check_button ~label:text ~active () in
    let c = b#coerce in
    let declare = ( function
        | `Active -> ()
        | `Checked f -> ignore(
                b#connect#toggled ~callback:(fun () -> f b#active))
        | #common_misc_properties as p -> 
                process_common_misc b p
    ) in
    List.iter declare properties;
    c

let label text properties =
    let lbl = GMisc.label ~text () in
    let c = lbl#coerce in
    let declare = ( function
        | `Help s ->
                tooltips#set_tip c ~text:s
    ) in
    List.iter declare properties;
    c
;;

let entry text properties =
    let e = GEdit.entry ~text () in
    let c = e#coerce in
    let declare = ( function
        | `Activate f ->
                ignore(e#connect#activate ~callback:(fun () -> f e#text))
        | #common_misc_properties as p -> process_common_misc e p
    ) in
    List.iter declare properties;
    c


(** [Containers] *)

let scrollable properties content =
    let scrolled_window = GBin.scrolled_window ~border_width:10
                        ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC () in
    scrolled_window#add_with_viewport content;
    List.iter (process_common_misc scrolled_window) properties;
    scrolled_window#coerce
;;

let box t properties contents =
    let make = match t with 
    `HORIZONTAL -> GPack.hbox | `VERTICAL -> GPack.vbox in
    let b = make () in
    let expand = List.mem `Expand_all properties in
    let fill = List.mem `Fill_all properties in
    List.iter (function `Expand_all | `Fill_all -> ()
        | #common_misc_properties as p -> process_common_misc b p
    ) properties;
    let c = b#coerce in
    List.iter (fun w -> b#pack ~expand ~fill w) contents;
    c

let hbox p c = box `HORIZONTAL p c
let vbox p c = box `VERTICAL p c

let boxp t properties =
    let make = match t with 
    `HORIZONTAL -> GPack.hbox | `VERTICAL -> GPack.vbox in
    let b = make () in
    let expand = true and fill = true in
    let c = b#coerce in
    List.iter (function
        | `Pack w -> b#pack w 
        | `Expand w -> b#pack ~expand w
        | `Fill w -> b#pack ~fill w
        | `Expand_fill w -> b#pack ~expand ~fill w
        | #common_misc_properties as p -> process_common_misc b p
    ) properties;
    c

let hboxp p = boxp `HORIZONTAL p
let vboxp p = boxp `VERTICAL p

let frame text content =
    let f = GBin.frame ~label:text () in
    f#add content;
    f#coerce
;;

let table (nx,ny) properties get_contents =
    let t = GPack.table ~rows:ny ~columns:nx () in
    for ix = 0 to nx - 1 do
        for iy = 0 to ny - 1 do
            ( match get_contents ix iy with
              | None -> ()
              | Some w -> 
                      t#attach ~left:ix ~top:iy ~expand:`BOTH w
            );
            flush stdout;
        done;
    done;
    t#coerce
;;

(** try to place list of widgets in square or rectangular table *)
let adapt_table properties l =
    let n = if l = [] then 1 else List.length l in
    let nx = int_of_float (sqrt (float n)) in
    let ny = (n+nx-1)/nx in
    let get_contents ix iy =
        let k = iy*nx + ix in
        if k < n 
        then Some (List.nth l k)
        else None
    in
    table (nx,ny) properties get_contents
;;

let notebook properties contents =
    let `Tab_pos tab_pos = List.hd (
        List.filter (function `Tab_pos _ -> true | _ -> false) 
                properties) in
    let nb = GPack.notebook ~tab_pos  ~scrollable:true () in
    let add (txt,widget) =
        ignore(nb#append_page ~tab_label:(label txt []) widget) in
    List.iter add contents;
    nb#coerce
;;

(** [misc] *)
let radio_buttons spec lst properties =
    let arr = Array.of_list lst in
    let default_n = 0 in
    let default = arr.(default_n) in
    let state = ref default in
    let default_callback = ref (fun _ -> ()) in
    let make label () = 
        if label = !state then () 
        else (state := label; !default_callback label) in
    let default_btn = GButton.radio_button ~label:default ~active:true () in
    default_btn#connect#clicked ~callback:(make default);
    let btns = Array.mapi (fun n label ->
        if n = default_n
        then default_btn
        else (
            let b = GButton.radio_button 
                ~label ~group:default_btn#group () in
            b#connect#clicked ~callback:(make label);
            b
        )
    ) arr in
    let declare = ( function
        | `Activate f ->
                default_callback := f
        | #common_misc_properties as p ->
                Array.iter (fun obj -> process_common_misc obj p) btns
    ) in
    List.iter declare properties;
    box spec [] (Array.to_list (Array.map (fun obj -> obj#coerce) btns))
;;

let combo init_text lst properties =
    let choices = GEdit.combo () in
    choices#set_popdown_strings lst;
    choices#entry#set_text init_text;
    let declare = ( function
        | `Activate f -> 
                let callback () = f choices#entry#text in
                ignore (choices#entry#connect#activate ~callback);
        | #common_misc_properties as p -> process_common_misc choices p
    ) in
    List.iter declare properties;
    choices#coerce
;;

let entry_list_button btn_text (l: string list) properties =
    let process_button = GButton.button ~label:btn_text () in
    let entry_list = List.map (fun txt ->
        let entry = GEdit.entry () in
        entry#set_text txt;
        entry
    ) l in
    let hbox = GPack.hbox () in
    List.iter (fun obj -> hbox#pack obj#coerce) entry_list;
    hbox#pack process_button#coerce;
    List.iter (function 
        | `Activate f ->
             let get_current_values () = List.map 
                (fun e -> e#text) 
                entry_list in
             let callback () = f (get_current_values ()) in
             ignore (process_button#connect#clicked ~callback);
             List.iter 
                (fun obj -> ignore (obj#connect#activate ~callback))
                entry_list
        | #common_properties as p -> 
                List.iter (fun obj -> process_common obj#coerce p) entry_list;
                process_common process_button#coerce p
        | #misc_properties as p -> 
                List.iter (fun obj -> process_misc obj p) entry_list
    ) properties;
    hbox#coerce
;;

let entry_button btn_text e_text properties =
    let transform = (function
        | `Activate g -> `Activate (g $ List.hd)
        | #common_misc_properties as p -> p
    ) in
    entry_list_button btn_text [e_text] (List.map transform properties)

let combo_list_button btn_text (ll: string list list) properties =
    let process_button = GButton.button ~label:btn_text () in
    let combo_list = List.map (fun lst ->
        let combo = GEdit.combo () in
        combo#set_popdown_strings lst;
        combo
    ) ll in
    let hbox = if List.mem `Vertical properties 
        then GPack.vbox () else GPack.hbox () in
    List.iter (fun obj -> hbox#pack ~expand:true obj#coerce) combo_list;
    hbox#pack process_button#coerce;
    List.iter (function 
        | `Vertical -> ()
        | `Activate f ->
             let get_current_values () = List.map 
                (fun combo -> combo#entry#text) 
                combo_list in
             let callback () = f (get_current_values ()) in
             ignore (process_button#connect#clicked ~callback);
             List.iter 
                (fun obj -> ignore (obj#entry#connect#activate ~callback))
                combo_list
        | #common_properties as p -> 
                List.iter (fun obj -> process_common obj#coerce p) combo_list;
                process_common process_button#coerce p
        | #misc_properties as p -> 
                List.iter (fun obj -> process_misc obj p) combo_list
    ) properties;
    hbox#coerce
;;
let combo_button text lst properties =
    let transform = (function
        | `Activate g -> `Activate (g $ List.hd)
        | #common_misc_properties as p -> p
    ) in
    combo_list_button text [lst] (List.map transform properties)
(*
let button_combo text lst properties =
    let process_button = GButton.button ~label:text () in
    let choices = GEdit.combo () in
    choices#set_popdown_strings lst;
    let c = process_button#coerce in
    let declare = ( function
        | `Activate f -> 
                let callback () = f choices#entry#text in
                ignore (process_button#connect#clicked ~callback);
                ignore (choices#entry#connect#activate ~callback);
        | #common_properties as p -> 
                process_common choices#coerce p; process_common c p
        | #misc_properties as p -> 
                process_misc choices p
    ) in
    List.iter declare properties;
    hbox [] [choices#coerce; c]
;;
*)

let button_popup_window title properties content =
    let window = GWindow.window ~title ~border_width:10 ~show:false () in
    window#add content;
    let declare = ( function
        | `Border_width i ->
                window#set_border_width i
    ) in
    List.iter declare properties;
    let show_btn = GButton.button ~label:(title^"...") () in
    ignore (show_btn#connect#clicked ~callback:window#show);
    ignore (window#event#connect#delete
                (fun _ -> window#misc#hide(); true));
    show_btn#coerce
;;
